home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_tut / meridian.ada < prev    next >
Encoding:
Text File  |  1996-01-30  |  2.8 KB  |  67 lines
  1. -- MERIDIAN.ADA   Ver. 3.00   22-AUG-1994   Copyright 1988-1994 John J. Herro
  2. -- Software Innovations Technology
  3. -- 1083 Mandarin Drive NE, Palm Bay, FL  32905-4706   (407)951-0233
  4. --
  5. -- Compile this before compiling ADA_TUTR.ADA, when using a PC with a Meridian
  6. -- Ada compiler and the Meridian DOS Environment Library.
  7. --
  8. with Tty;
  9. package Custom_IO is
  10.    type Color is (Black, Red, Green, Yellow, Blue, Magenta, Cyan, White);
  11.    Foregrnd_Color   : Color := White;                 -- Default values in case
  12.    Backgrnd_Color   : Color := Black;                 -- ADA-TUTR finds no User
  13.    Border_Color     : Color := Black;                 -- File.
  14.    Fore_Color_Digit : Character := Character'Val(Color'Pos(Foregrnd_Color)+48);
  15.    Back_Color_Digit : Character := Character'Val(Color'Pos(Backgrnd_Color)+48);
  16.    Normal_Colors    : String(1 .. 10) := ASCII.ESC & "[0;3" &
  17.                             Fore_Color_Digit & ";4" & Back_Color_Digit & "m";
  18.    Clear_Scrn       : constant String := ASCII.ESC & "[H" & ASCII.ESC &"[2J";
  19.  
  20.    procedure Set_Border_Color (To   : in  Color);
  21.    procedure Get              (Char : out Character);
  22.    procedure Put              (Char : in  Character) renames Tty.Put;
  23.    procedure Put              (Str  : in  String)    renames Tty.Put;
  24.    procedure Put_Line         (Str  : in  String)    renames Tty.Put_Line;
  25.    procedure Get_Line         (Str  : out String; Last : out Natural);
  26.    procedure New_Line;
  27. end Custom_IO;
  28.  
  29. with Interrupt;
  30. package body Custom_IO is
  31.    procedure Set_Border_Color(To : in Color) is
  32.       --
  33.       -- This procedure sets the border color on a PC by calling interrupt
  34.       -- 10 hex.  Before the call, register AH is set to service number 0B hex,
  35.       -- BH is set to zero, and BL is set to an integer as shown in the
  36.       -- declaration of Color_Number below.  Note that the integers in
  37.       -- Color_Number are bit reversed from the integers defining foreground
  38.       -- and background colors in ANSI escape sequences.  Note also that some
  39.       -- color PCs don't have separate border colors.
  40.       --
  41.       Regis_Block  : Interrupt.Registers;
  42.       Color_Number : constant array(Color) of Integer :=
  43.           (Black   => 0,   Red     => 4,   Green   => 2,   Yellow  => 6,
  44.            Blue    => 1,   Magenta => 5,   Cyan    => 3,   White   => 7);
  45.    begin
  46.       Regis_Block.AX := 16#0B00#;
  47.       Regis_Block.BX := 16#0000# + COLOR_NUMBER(TO);
  48.       Interrupt.Vector(On => 16#10#, Register_Block => Regis_Block);
  49.    end Set_Border_Color;
  50.  
  51.    procedure Get(Char : out Character) is
  52.    begin
  53.       Char := Tty.Get(No_Echo => True);
  54.    end Get;
  55.  
  56.    procedure Get_Line(Str : out String; Last : out Natural) is
  57.    begin
  58.       Tty.Get(Str, Last);
  59.       New_Line;
  60.    end Get_Line;
  61.  
  62.    procedure New_Line is
  63.    begin
  64.       Put_Line("");
  65.    end New_Line;
  66. end Custom_IO;
  67.